Ham Radio 2000 #1/Ham Radio 2000.iso/ham2000/packet/p_aa4re/bb212src/bbstr.pas

Pascal/Delphi Source File | 1991-12-15 | 13.4 KB | 513 lines

(*===========================================================================*)
(* String service routines                                                   *)
(*                                                                           *)
(*   Copyright 1988, 1989 by H. Roy Engehausen.  All rights reserved.        *)
(*                                                                           *)
(*===========================================================================*)

{$R-}

UNIT BBSTR;

INTERFACE

USES
  bbdummy;

FUNCTION  w2c            (    inw        : WORD  ) : str5;
FUNCTION  substr         (VAR instr      : STRING;
                              start_chr  : BYTE;
                              length_chr : BYTE)   : STRING;
FUNCTION  subword        (    instr      : str_ptr;
                              inpoint    : BYTE;
                              incnt      : BYTE)   : STRING;
FUNCTION  subwordl       (VAR instr      : STRING;
                              inpoint    : BYTE;
                              incnt      : BYTE)   : STRING;
FUNCTION  words          (VAR instr      : STRING) : BYTE;
FUNCTION  strip          (VAR instr      : STRING;
                              st_type    : CHAR)   : STRING;
PROCEDURE strip_var      (VAR instr      : STRING;
                              st_type    : CHAR);
PROCEDURE strip_crlf     (VAR instr      : STRING);
FUNCTION  left           (    instr      : STRING;
                              length_chr : BYTE)   : STRING;
PROCEDURE upcase_str_var (VAR instr      : STRING);
FUNCTION  upcase_str     (    instr      : STRING) : STRING;
FUNCTION  find           (    haystack   : str_ptr;
                              needle     : str_ptr) : BYTE;
FUNCTION  substr_compare (VAR instr      : STRING;
                              start_chr  : BYTE;
                              compare_str: STRING)  : BOOLEAN;

IMPLEMENTATION

USES
  bbstack;

{$DEFINE DEPTH}

{$I ASCII.PAS}

(*===========================================================================*)
(* Convert a word to a decimal number                                        *)
(*===========================================================================*)

FUNCTION w2c(inw : WORD) : str5;
  VAR
    out : str5;

  BEGIN;

    STR(inw, out);
    w2c := out;

  END;

(*===========================================================================*)
(* Substring a string.  LENGTH_CHR = 0 means the rest of the string          *)
(*    Contrary to the declartion, instr is not VAR.  Thats just to produce   *)
(*    nicer code                                                             *)
(*===========================================================================*)

FUNCTION  substr(VAR instr      : STRING;
                     start_chr  : BYTE;
                     length_chr : BYTE) : STRING;

  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    IF length_chr = 0 THEN
      length_chr := 255;

    substr := COPY(instr, start_chr, length_chr);

  END;

(*===========================================================================*)
(* Subword a string.  INCNT = 0 means the rest of the string                 *)
(*    Contrary to the declartion, instr is not VAR.  Thats just to produce   *)
(*    nicer code                                                             *)
(*===========================================================================*)

FUNCTION subword(instr : str_ptr; inpoint : BYTE; incnt : BYTE) : STRING;

  VAR
    chr_ptr    : BYTE;
    in_l       : BYTE;
    word_start : BYTE;
    word_cnt   : BYTE;
    word_end   : BYTE;
    out_str    : STRING;

  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    word_cnt := 0;
    chr_ptr  := 0;
    out_str  := '';
    in_l     := LENGTH(instr^);

    IF incnt = 0 THEN
      incnt := in_l;

    WHILE (word_cnt < (inpoint + incnt - 1))
                         AND (chr_ptr < in_l) DO
      BEGIN;

        WHILE (chr_ptr < in_l) AND (instr^[chr_ptr+1] = ' ') DO
          INC(chr_ptr);

        word_start := chr_ptr + 1;

        WHILE (chr_ptr < in_l) AND (instr^[chr_ptr+1] <> ' ') DO
          INC(chr_ptr);

        word_end := chr_ptr;

        INC(word_cnt);

        IF word_cnt >= inpoint THEN
          BEGIN;
            IF word_start <= word_end THEN
              IF LENGTH(out_str) > 0 THEN
                out_str := out_str + ' ' +
                  COPY(instr^, word_start, word_end-word_start+1)
              ELSE
                out_str := COPY(instr^, word_start, word_end-word_start+1);
          END;

      END;

    subword := out_str;

  END;

(*===========================================================================*)
(* Subword a string.  INCNT = max number of characters to output             *)
(*    Contrary to the declartion, instr is not VAR.  Thats just to produce   *)
(*    nicer code                                                             *)
(*===========================================================================*)

FUNCTION subwordl(VAR instr : STRING; inpoint : BYTE; incnt : BYTE) : STRING;

  VAR
    chr_ptr    : BYTE;
    word_start : BYTE;
    word_cnt   : BYTE;
    word_end   : BYTE;
    out_cnt    : BYTE;

  BEGIN;

    word_cnt := 0;
    chr_ptr  := 0;

    WHILE (word_cnt < inpoint) AND (chr_ptr < LENGTH(instr)) DO
      BEGIN;

        WHILE (chr_ptr < LENGTH(instr)) AND (instr[chr_ptr+1] = ' ') DO
          INC(chr_ptr);

        word_start := chr_ptr + 1;

        WHILE (chr_ptr < LENGTH(instr)) AND (instr[chr_ptr+1] <> ' ') DO
          INC(chr_ptr);

        word_end := chr_ptr;

        INC(word_cnt);

        IF word_cnt >= inpoint THEN
          BEGIN;
            out_cnt := word_end - word_start+1;
            IF out_cnt > incnt THEN
              out_cnt := incnt;

            subwordl := COPY(instr, word_start, out_cnt);
            EXIT;
          END;

      END;

    subwordl := '';

  END;

(*===========================================================================*)
(* Count words in a string                                                   *)
(*    Contrary to the declartion, instr is not VAR.  Thats just to produce   *)
(*    nicer code                                                             *)
(*===========================================================================*)

FUNCTION words(VAR instr : STRING) : BYTE;

  VAR
    chr_ptr    : BYTE;
    len        : BYTE;
    word_cnt   : BYTE;

  BEGIN;

    chr_ptr  := 0;
    word_cnt := 0;
    len      := LENGTH(instr);

    WHILE chr_ptr < len DO
      BEGIN;

        WHILE (chr_ptr < len) AND (instr[chr_ptr+1] = ' ') DO
          INC(chr_ptr);

        IF chr_ptr < len THEN
          INC(word_cnt);

        WHILE (chr_ptr < len) AND (instr[chr_ptr+1] <> ' ') DO
          INC(chr_ptr);

      END;

    words := word_cnt;

  END;

(*===========================================================================*)
(* Strip blanks off a string.  Leading, trailing, or both                    *)
(*    Contrary to the declartion, instr is not VAR.  Thats just to produce   *)
(*    nicer code                                                             *)
(*===========================================================================*)

FUNCTION strip (VAR instr : STRING; st_type : CHAR) : STRING;
  VAR
    start_pos : BYTE;
    end_pos   : INTEGER;
  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    start_pos := 1;
    end_pos := LENGTH(instr);

    IF (st_type = 'B') OR (st_type = 'L') THEN
      WHILE (start_pos <= end_pos) AND (instr[start_pos] = ' ') DO
        INC(start_pos);

    IF (st_type = 'B') OR (st_type = 'T') THEN
      WHILE (end_pos >= start_pos) AND (instr[end_pos] = ' ') DO
        end_pos := end_pos - 1;

    end_pos := end_pos - start_pos + 1;

    IF end_pos > 0 THEN
      strip := COPY(instr, start_pos, end_pos)
    ELSE
      strip := '';

  END;

(*===========================================================================*)
(* Strip blanks off a string.  Leading, trailing, or both                    *)
(*===========================================================================*)

PROCEDURE strip_var (VAR instr : STRING; st_type : CHAR);
  VAR
    start_pos : INTEGER;
    end_pos   : INTEGER;
  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    start_pos := 1;
    end_pos := LENGTH(instr);

    IF (st_type = 'B') OR (st_type = 'L') THEN
      WHILE (start_pos <= end_pos) AND (instr[start_pos] = ' ') DO
        INC(start_pos);

    IF (st_type = 'B') OR (st_type = 'T') THEN
      WHILE (end_pos >= start_pos) AND (instr[end_pos] = ' ') DO
        end_pos := end_pos - 1;

    end_pos := end_pos - start_pos + 1;

    IF (end_pos > 0) AND (start_pos > 1) THEN
      MOVE(instr[start_pos], instr[1], end_pos);

    instr[0] := CHR(end_pos);

  END;

(*===========================================================================*)
(* Strip CRLF off the tail of a string.  Also strip LF from front            *)
(*===========================================================================*)

PROCEDURE strip_crlf(VAR instr : STRING);

  VAR
    c : CHAR;
    i : BYTE;
    j : BYTE;

  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    i := LENGTH(instr);
    c := instr[i];
    WHILE (i > 0) AND ((c = cr) OR (c = lf) OR (c = ' ')) DO
      BEGIN;
        DEC(i);
        c := instr[i];
      END;

    j := 1;
    c := instr[1];
    WHILE (i > 0) AND ((c = cr) OR (c = lf) OR (c = ' ')) DO
      BEGIN;
        DEC(i);
        INC(j);
        c := instr[j];
      END;

    IF (i > 0) AND (j <> 1) THEN
      MOVE(instr[j], instr[1], i);

    instr[0] := CHR(i);

  END;

(*===========================================================================*)
(* Left justify a string                                                     *)
(*===========================================================================*)

FUNCTION left(instr : STRING; length_chr : BYTE) : STRING;

  VAR
    i     : INTEGER;

  BEGIN;

    i := length_chr - LENGTH(instr);

    IF i < 0 THEN
      BEGIN;
        left := COPY(instr, 1, length_chr);
        EXIT;
      END;

    IF i = 0 THEN
      BEGIN;
        left := instr;
        EXIT;
      END;

    FILLCHAR(instr[LENGTH(instr) + 1], i, ' ');
    instr[0] := CHR(length_chr);

    left := instr;

  END;

(*===========================================================================*)
(* Uppercase a string variable                                               *)
(*===========================================================================*)

PROCEDURE upcase_str_var(VAR instr : STRING);

  VAR
    i : BYTE;
    j : BYTE;

  BEGIN;

    i := 0;
    j := LENGTH(instr);
    WHILE i < j DO
      BEGIN;
        INC(i);
        instr[i] := UPCASE(instr[i]);
      END;
  END;

(*===========================================================================*)
(* Uppercase a string.                                                       *)
(*===========================================================================*)

FUNCTION upcase_str(instr : STRING) : STRING;

  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    upcase_str_var(instr);
    upcase_str := instr;

  END;

(*===========================================================================*)
(* Find a word in a string                                                   *)
(*    Contrary to the declartion, haystack and needle are not VAR.  Thats    *)
(*    just to save stack space                                               *)
(*===========================================================================*)

FUNCTION find(haystack : str_ptr; needle : str_ptr) : BYTE;

  VAR
    i          : WORD;
    j          : WORD;
    k          : WORD;
    l_haystack : BYTE;
    l_needle   : BYTE;
    w          : BYTE;

  BEGIN;

{$IFDEF DEPTH}
stack_depth;
{$ENDIF}

    i          := 1;
    l_haystack := LENGTH(haystack^);
    l_needle   := LENGTH(needle^);
    w          := 0;
    find       := 0;

    WHILE i <= l_haystack DO
      BEGIN;

        INC(w);

        WHILE (i <= l_haystack) AND (haystack^[i] = ' ') DO
          INC(i);

        IF i > l_haystack THEN EXIT;

        j := i + l_needle - 1;

        IF j > l_haystack THEN EXIT;

        IF ((j < l_haystack) AND (haystack^[j + 1] = ' '))
                                            OR (j = l_haystack) THEN
          BEGIN;

            k := 1;
            WHILE (k <= l_needle) AND (haystack^[i] = needle^[k]) DO
              BEGIN;
                INC(k);
                INC(i);
              END;

            IF k > l_needle THEN
              BEGIN;
                find := w;
                EXIT;
              END;

          END;

        WHILE (i <= l_haystack) AND (haystack^[i] <> ' ') DO
          INC(i);

      END;

  END;

FUNCTION  substr_compare (VAR instr      : STRING;
                              start_chr  : BYTE;
                              compare_str: STRING)  : BOOLEAN;
  VAR
    i : BYTE;
  BEGIN;

    substr_compare := FALSE;

    IF (start_chr + LENGTH(compare_str) - 1) > LENGTH(instr) THEN
      EXIT;

    i := 0;
    WHILE (i < LENGTH(compare_str)) DO
      BEGIN;
        IF instr[i + start_chr] <> compare_str[i + 1] THEN EXIT;
        INC(i);
      END;

    substr_compare := TRUE;

  END;

END.